home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / URI / urn.pm < prev    next >
Text File  |  2008-04-02  |  2KB  |  98 lines
  1. package URI::urn;  # RFC 2141
  2.  
  3. require URI;
  4. @ISA=qw(URI);
  5.  
  6. use strict;
  7. use Carp qw(carp);
  8.  
  9. use vars qw(%implementor);
  10.  
  11. sub _init {
  12.     my $class = shift;
  13.     my $self = $class->SUPER::_init(@_);
  14.     my $nid = $self->nid;
  15.  
  16.     my $impclass = $implementor{$nid};
  17.     return $impclass->_urn_init($self, $nid) if $impclass;
  18.  
  19.     $impclass = "URI::urn";
  20.     if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) {
  21.     my $id = $nid;
  22.     # make it a legal perl identifier
  23.     $id =~ s/-/_/g;
  24.     $id = "_$id" if $id =~ /^\d/;
  25.  
  26.     $impclass = "URI::urn::$id";
  27.     no strict 'refs';
  28.     unless (@{"${impclass}::ISA"}) {
  29.         # Try to load it
  30.         eval "require $impclass";
  31.         die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
  32.         $impclass = "URI::urn" unless @{"${impclass}::ISA"};
  33.     }
  34.     }
  35.     else {
  36.     carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W;
  37.     }
  38.     $implementor{$nid} = $impclass;
  39.  
  40.     return $impclass->_urn_init($self, $nid);
  41. }
  42.  
  43. sub _urn_init {
  44.     my($class, $self, $nid) = @_;
  45.     bless $self, $class;
  46. }
  47.  
  48. sub _nid {
  49.     my $self = shift;
  50.     my $opaque = $self->opaque;
  51.     if (@_) {
  52.     my $v = $opaque;
  53.     my $new = shift;
  54.     $v =~ s/[^:]*/$new/;
  55.     $self->opaque($v);
  56.     # XXX possible rebless
  57.     }
  58.     $opaque =~ s/:.*//s;
  59.     return $opaque;
  60. }
  61.  
  62. sub nid {  # namespace identifier
  63.     my $self = shift;
  64.     my $nid = $self->_nid(@_);
  65.     $nid = lc($nid) if defined($nid);
  66.     return $nid;
  67. }
  68.  
  69. sub nss {  # namespace specific string
  70.     my $self = shift;
  71.     my $opaque = $self->opaque;
  72.     if (@_) {
  73.     my $v = $opaque;
  74.     my $new = shift;
  75.     if (defined $new) {
  76.         $v =~ s/(:|\z).*/:$new/;
  77.     }
  78.     else {
  79.         $v =~ s/:.*//s;
  80.     }
  81.     $self->opaque($v);
  82.     }
  83.     return undef unless $opaque =~ s/^[^:]*://;
  84.     return $opaque;
  85. }
  86.  
  87. sub canonical {
  88.     my $self = shift;
  89.     my $nid = $self->_nid;
  90.     my $new = $self->SUPER::canonical;
  91.     return $new if $nid !~ /[A-Z]/ || $nid =~ /%/;
  92.     $new = $new->clone if $new == $self;
  93.     $new->nid(lc($nid));
  94.     return $new;
  95. }
  96.  
  97. 1;
  98.